home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlsys.c < prev   
Encoding:
C/C++ Source or Header  |  1990-11-09  |  7.8 KB  |  399 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* external variables */
  10. extern FILE *tfp;
  11.  
  12. /* external symbols */
  13. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  14. extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
  15. extern LVAL a_vector,a_closure,a_char,a_ustream;
  16. extern LVAL k_verbose,k_print;
  17. extern LVAL true;
  18.  
  19.  
  20. /* xload - read and evaluate expressions from a file */
  21. LVAL xload()
  22. {
  23.     char *name;
  24.     int vflag,pflag;
  25.     LVAL arg;
  26.  
  27.     /* get the file name */
  28.     name = getstring(xlgetfname());
  29.  
  30.     /* get the :verbose flag */
  31.     if (xlgetkeyarg(k_verbose,&arg))
  32.         vflag = (arg != NIL);
  33.     else
  34.         vflag = TRUE;
  35.  
  36.     /* get the :print flag */
  37.     if (xlgetkeyarg(k_print,&arg))
  38.         pflag = (arg != NIL);
  39.     else
  40.         pflag = FALSE;
  41.  
  42.     /* load the file */
  43.     return (xlload(name,vflag,pflag) ? true : NIL);
  44. }
  45.  
  46. /* xtranscript - open or close a transcript file */
  47. LVAL xtranscript()
  48. {
  49.     char *name;
  50.  
  51.     /* get the transcript file name */
  52.     name = (moreargs() ? getstring(xlgetfname()) : NULL);
  53.     xllastarg();
  54.  
  55.     /* close the current transcript */
  56.     if (tfp) osclose(tfp);
  57.  
  58.     /* open the new transcript */
  59.     tfp = (name ? osaopen(name,"w") : NULL);
  60.  
  61.     /* return T if a transcript is open, NIL otherwise */
  62.     return (tfp ? true : NIL);
  63. }
  64.  
  65. /* xtype - return type of a thing */
  66. LVAL xtype()
  67. {
  68.     LVAL arg;
  69.  
  70.     if ((arg = xlgetarg()) == 0)
  71.         return (NIL);
  72.  
  73.     switch (ntype(arg)) {
  74.     case SUBR:            return (a_subr);
  75.     case FSUBR:            return (a_fsubr);
  76.     case CONS:            return (a_cons);
  77.     case SYMBOL:        return (a_symbol);
  78.     case FIXNUM:        return (a_fixnum);
  79.     case FLONUM:        return (a_flonum);
  80.     case STRING:        return (a_string);
  81.     case OBJECT:        return (a_object);
  82.     case STREAM:        return (a_stream);
  83.     case VECTOR:        return (a_vector);
  84.     case CLOSURE:        return (a_closure);
  85.     case CHAR:            return (a_char);
  86.     case USTREAM:        return (a_ustream);
  87. #ifdef STRUCTS
  88.     case STRUCT:        return (getelement(arg,0));
  89. #endif
  90.     default:            xlfail("bad node type");
  91.                         return (NIL); /* eliminate warning message */
  92.     }
  93. }
  94.  
  95. #ifdef COMMONLISP
  96. int xlcvttype(arg)    /* find type of argument and return it */
  97. LVAL arg;
  98. {
  99.     if (arg == a_subr)        return SUBR;
  100.     if (arg == a_fsubr)        return FSUBR;
  101.     if (arg == a_cons)        return CONS;
  102.     if (arg == a_symbol)    return SYMBOL;
  103.     if (arg == a_fixnum)    return FIXNUM;
  104.     if (arg == a_flonum)    return FLONUM;
  105.     if (arg == a_string)    return STRING;
  106.     if (arg == a_object)    return OBJECT;
  107.     if (arg == a_stream)    return STREAM;
  108.     if (arg == a_vector)    return VECTOR;
  109.     if (arg == a_closure)    return CLOSURE;
  110.     if (arg == a_char)        return CHAR;
  111.     if (arg == a_ustream)    return USTREAM;
  112.     return 0;
  113. }
  114.  
  115. #ifdef ANSI
  116. static LVAL listify(LVAL arg)    /* arg must be vector or string */
  117. #else
  118. LOCAL LVAL listify(arg)    /* arg must be vector or string */
  119. LVAL arg;
  120. #endif
  121. {
  122.     LVAL val;
  123.     int i;
  124.     
  125.     xlsave1(val);
  126.     
  127.     if (ntype(arg) == VECTOR) {
  128.         for (i = getsize(arg); i-- > 0; ) 
  129.             val = cons(getelement(arg,i),val);
  130.     }
  131.     else {    /* a string */
  132.         for (i = getslength(arg)-1; i-- > 0; )
  133.             val = cons(cvchar(getstringch(arg,i)),val);
  134.     }
  135.     
  136.     xlpop();
  137.     return (val);
  138. }
  139.  
  140. #ifdef ANSI
  141. static LVAL vectify(LVAL arg)    /* arg must be string or cons */
  142. #else
  143. LOCAL LVAL vectify(arg)    /* arg must be string or cons */
  144. LVAL arg;
  145. #endif
  146. {
  147.     LVAL val,temp;
  148.     int i,l;
  149.     
  150.     if (ntype(arg) == STRING) {
  151.         l = getslength(arg)-1;
  152.         val = newvector(l);
  153.         for (i=0; i < l; i++) setelement(val,i,cvchar(getstringch(arg,i)));
  154.     }
  155.     else {    /* a cons */
  156.         val = arg;
  157.         for (l = 0; consp(val); l++) val = cdr(val); /* get length */
  158.         val = newvector(l);
  159.         temp = arg;
  160.         for (i = 0; i < l; i++) {
  161.             setelement(val,i,car(temp));
  162.             temp = cdr(temp);
  163.         }
  164.     }
  165.         return val;
  166. }
  167.  
  168. #ifdef ANSI
  169. static LVAL stringify(LVAL arg)
  170. #else
  171. LOCAL LVAL stringify(arg)    /* arg must be vector or cons */
  172. LVAL arg;
  173. #endif
  174. {
  175.     LVAL val,temp;
  176.     int i,l;
  177.     
  178.     if (ntype(arg) == VECTOR) {
  179.         l = getsize(arg);
  180.         val = newstring(l+1);
  181.         for (i=0; i < l; i++) {
  182.             temp = getelement(arg,i);
  183.             if (ntype(temp) != CHAR) goto failed;
  184.             val->n_string[i] = getchcode(temp);
  185.         }
  186.         val->n_string[l] = 0;
  187.         return val;
  188.     }
  189.     else {    /* must be cons */
  190.         val = arg;
  191.         for (l = 0; consp(val); l++) {
  192.             if (ntype(car(val)) != CHAR) goto failed;
  193.             val = cdr(val); /* get length */
  194.         }
  195.  
  196.         val = newstring(l+1);
  197.         temp = arg;
  198.         for (i = 0; i < l; i++) {
  199.             val->n_string[i] = getchcode(car(temp));
  200.             temp = cdr(temp);
  201.         }
  202.         val->n_string[l] = 0;
  203.         return val;
  204.     }
  205. failed:
  206.     xlerror("cannot make into string", arg);
  207.     return (NIL);    /* avoid compiler warnings */
  208. }
  209.  
  210.  
  211.  
  212. /* coerce function */
  213. LVAL xcoerce()
  214. {
  215.     LVAL type, arg, temp;
  216.     int newtype,oldtype;
  217.  
  218.     arg = xlgetarg();
  219.     type = xlgetarg();
  220.     xllastarg();
  221.     
  222.     if ((newtype = xlcvttype(type)) == 0) goto badconvert;
  223.  
  224.     oldtype = ntype(arg);
  225.     if (oldtype == newtype) return (arg);    /* easy case! */
  226.     
  227.     switch (newtype) {
  228.         case CONS: if ((oldtype == STRING)|(oldtype == VECTOR))
  229.             return (listify(arg));
  230.             break;
  231.         case STRING: if ((oldtype == CONS)|(oldtype == VECTOR))
  232.             return (stringify(arg));
  233.             break;
  234.         case VECTOR: if ((oldtype == STRING) | (oldtype == CONS))
  235.             return (vectify(arg));
  236.             break;
  237.         case CHAR:
  238.             if (oldtype == FIXNUM) return cvchar((int)getfixnum(arg));
  239.             else if ((oldtype == STRING) && (getslength(arg) == 2))
  240.                 return cvchar(getstringch(arg,0));
  241.             else if (oldtype == SYMBOL) {
  242.                 temp = getpname(arg);
  243.                 if (getslength(temp) == 2) return cvchar(getstringch(temp,0));
  244.             }
  245.             break;
  246.         case FLONUM:
  247.             if (oldtype == FIXNUM) return (cvflonum(1.0*(int)getfixnum(arg)));
  248.             break;
  249.     }
  250.  
  251.  
  252. badconvert:
  253.     xlerror("illegal coersion",arg);
  254.     return (NIL);    /* avoid compiler warnings */
  255. }
  256.  
  257.  
  258. #endif
  259.  
  260.  
  261. #ifdef ADDEDTAA
  262. /* xgeneric - get generic representation of thing */
  263. /* TAA addition */
  264. LVAL xgeneric()
  265. {
  266.     LVAL arg,acopy;
  267.     
  268.     arg = xlgetarg();
  269.     xllastarg();
  270.     if (arg == NIL)  return (NIL);
  271.     
  272.     switch (ntype(arg)) {
  273.     case CONS: case USTREAM:
  274.         return (cons(car(arg),cdr(arg)));
  275.     case SYMBOL: case OBJECT: case VECTOR: case CLOSURE:
  276. #ifdef STRUCTS
  277.     case STRUCT:
  278. #endif
  279.         acopy = newvector(getsize(arg));
  280.         memcpy(acopy->n_vdata, arg->n_vdata, getsize(arg)*sizeof(LVAL));
  281.         return (acopy);
  282.     case STRING: /* make a copy of the string */
  283.         acopy = newstring(getslength(arg));
  284.         memcpy(getstring(acopy), getstring(arg), getslength(arg));
  285.         return (acopy);
  286.     case FIXNUM: case FLONUM: case CHAR:
  287.         return (arg); /* it hardly matters to copy these */
  288.     default:    xlbadtype(arg);
  289.         return (NIL);    /* avoid compiler warnings */
  290.     }
  291. }
  292.  
  293.  
  294. /* xtime - report execution time */
  295. /* TAA addition */
  296. #include <time.h>
  297.  
  298. #ifdef NDP386
  299. LVAL xtime()
  300. {
  301.     LVAL expr;
  302.     
  303.     double t1, t2;
  304.     
  305.     expr = xlgetarg();
  306.     xllastarg();
  307.     t1 = sec_100_();
  308.     xleval(expr);
  309.     t2 = sec_100_();
  310.     return(cvflonum((t2-t1)*100.0));
  311. }
  312. #else
  313. LVAL xtime()
  314. {
  315.     LVAL expr;
  316.     
  317.     clock_t t1, t2;
  318.     
  319.     expr = xlgetarg();
  320.     xllastarg();
  321.     t1 = clock();
  322.     xleval(expr);
  323.     t2 = clock();
  324.     return(cvflonum(((t2-t1)*1.0)/CLK_TCK));
  325. }
  326. #endif
  327. #endif
  328.  
  329. /* xbaktrace - print the trace back stack */
  330. LVAL xbaktrace()
  331. {
  332.     LVAL num;
  333.     int n;
  334.  
  335.     if (moreargs()) {
  336.         num = xlgafixnum();
  337.         n = (int)getfixnum(num);
  338.     }
  339.     else
  340.         n = -1;
  341.     xllastarg();
  342.     xlbaktrace(n);
  343.     return (NIL);
  344. }
  345.  
  346. /* xexit - get out of xlisp */
  347. LVAL xexit()
  348. {
  349.     xllastarg();
  350.     wrapup();
  351.     return (NIL); /* never returns */
  352. }
  353.  
  354. /* xpeek - peek at a location in memory */
  355. LVAL xpeek()
  356. {
  357.     LVAL num;
  358.     int *adr;
  359.  
  360.     /* get the address */
  361.     num = xlgafixnum(); adr = (int *)getfixnum(num);
  362.     xllastarg();
  363.  
  364.     /* return the value at that address */
  365.     return (cvfixnum((FIXTYPE)*adr));
  366. }
  367.  
  368. /* xpoke - poke a value into memory */
  369. LVAL xpoke()
  370. {
  371.     LVAL val;
  372.     int *adr;
  373.  
  374.     /* get the address and the new value */
  375.     val = xlgafixnum(); adr = (int *)getfixnum(val);
  376.     val = xlgafixnum();
  377.     xllastarg();
  378.  
  379.     /* store the new value */
  380.     *adr = (int)getfixnum(val);
  381.  
  382.     /* return the new value */
  383.     return (val);
  384. }
  385.  
  386. /* xaddrs - get the address of an XLISP node */
  387. LVAL xaddrs()
  388. {
  389.     LVAL val;
  390.  
  391.     /* get the node */
  392.     val = xlgetarg();
  393.     xllastarg();
  394.  
  395.     /* return the address of the node */
  396.     return (cvfixnum((FIXTYPE)val));
  397. }
  398.  
  399.